COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	   EXTSTR			 	  		  -*-LISP-*-
C00006 00003
C00012 ENDMK
C⊗;
;;;   EXTSTR			 	  		  -*-LISP-*-
;;;   ***************************************************************
;;;   *** MACLISP **** EXTENDed Datatype Scheme, Basic Heirarchy ****
;;;   ***************************************************************
;;;   ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ***
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES REVERSED) ********
;;;   ***************************************************************

;;; Wherein we build HUNKs for each class that will be directly pointed to
;;; by classes defined by DEFVST.  We leave out the interconnections between
;;; classes, to help printing of objects defined by DEFVST.  Loading EXTEND
;;; will supply the missing interconnections.

;;; We also define the basic CLASS creator, SI:DEFCLASS*-2 a sub-primitive that
;;; gives a skeletal class.  This class can then be filled in by calling
;;; SI:INITIALIZE-CLASS (from EXTEND)

(herald EXTSTR /79)

(eval-when (eval compile)
  (macro lispdir (x)
	(setq x (cadr x))
	#+Pdp10   `(QUOTE ((LISP) ,x FASL))
	#+Lispm   (string-append "lisp;" (get-pname x) "qfasl")
	#+Multics (catenate ">exl>lisp←dir>object" (get←pname x))
	#+For-NIL (string-append "lisp:" (get-pname x) "vasl")
	)
  (macro subload (x)
	(setq x (cadr x))
	`(OR (GET ',x 'VERSION) (LOAD #%(lispdir ,x))))
  (subload UMLMAC)
  (subload EXTBAS)
   ;; Remember, EXTMAC down-loads CERROR
  (subload EXTMAC)
  ;; This would like to be a SUBLOAD of VECTOR, but this way it's not circular
  (defcomplrmac VSET (v n val) `(SI:XSET ,v ,n ,val))
 )


(defvar SI:CLASS-MARKER '**CLASS-SELF-EVAL**)


(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps")
(defvar CLASS-CLASS () "Will be set up, at some pain, in this file")
(defvar OBJECT-CLASS () "Will be set up, at some pain, in this file")

(declare (special STRUCT=INFO-CLASS STRUCT-CLASS VECTOR-CLASS))

(declare (own-symbol **SELF-EVAL** SI:DEFCLASS*-2 SI:DEFVST-BARE-INIT))

;; Will be compiled, but no defmacro-displace-call action
(defun (**SELF-EVAL** MACRO) (x) `',x)
;; So we can tell classes apart
(putprop SI:CLASS-MARKER (get '**SELF-EVAL** 'MACRO) 'MACRO)


;;;; SI:DEFCLASS*-2

(defun SI:DEFCLASS*-2 (name typep var superiors &optional source-file)
  (let ((class (si:make-extend #.si:class-instance-size 
			       CLASS-CLASS)))
    (setf (si:extend-marker-of class) SI:CLASS-MARKER)
    (setf (si:class-typep class) typep)
    (setf (si:class-plist class) (ncons name))
    (setf (si:class-name class) name)
    (if source-file
	(setf (get (si:class-plist class) ':SOURCE-FILE) source-file))	      
    (when var
	  (set var class)
	  (setf (si:class-var class) var))
    (if (getl 'SI:INITIALIZE-CLASS '(SUBR EXPR))
	(progn (setf (si:class-superiors class) superiors)
	       (si:initialize-class class))
	(push `(,class ,superiors) SI:SKELETAL-CLASSES)
	(setf (si:extend-class-of class) () )
	(if (boundp 'PURCOPY) (push class PURCOPY)))
    (putprop name class 'CLASS)
    class))

(defun SI:DEFVST-BARE-INIT (name var-name cnsn size inis
				 &optional (version 1) source-file)
  (putprop name
	   (si:extend STRUCT=INFO-CLASS
		      version name cnsn size
		      (cond ((or (null inis) (not (pairp inis)))
			      inis)
			    ((do ((idx 0 (1+ idx))
				  (vector (si:make-extend 
					      (length inis)
					      VECTOR-CLASS))
				  (inis inis (cdr inis)))
				 ((null inis) vector)
			       (declare (fixnum idx))
			       (vset vector idx (car inis)))))
		      (or (get name 'CLASS)
			  (si:defclass*-2 name name var-name
					  (ncons STRUCT-CLASS)
					  source-file)))
	   'STRUCT=INFO)
  (setf (get (si:class-plist (get name 'CLASS)) 'STRUCT=INFO)
	(get name 'STRUCT=INFO)))

;; Setup basics of CLASS hierarchy, if not already done so.  DEFVAR
;;  at beginning of this file ensures that CLASS-CLASS has a value.
(and (null CLASS-CLASS)
     (let ((z (plist 'CLASSP)))
       (unwind-protect 
	  (progn  ;; Oh, come on, there's gotta be a better way than this!
	     (setplist 'CLASSP `(EXPR (LAMBDA (X) 'T) ,. (plist 'CLASSP)))
	     (sstatus uuoli)
	     (si:defclass*-2 'OBJECT 'OBJECT 'OBJECT-CLASS () )
	     (si:defclass*-2 'CLASS 'CLASS 'CLASS-CLASS `(,OBJECT-CLASS)))
	     (si:defclass*-2 'SEQUENCE 'SEQUENCE 'SEQUENCE-CLASS
			     `(,OBJECT-CLASS))
	     (si:defclass*-2 'VECTOR 'VECTOR 'VECTOR-CLASS `(,SEQUENCE-CLASS))
	     (si:defclass*-2 'STRUCT 'STRUCT 'STRUCT-CLASS `(,OBJECT-CLASS))
	     (si:defclass*-2 'STRUCT=INFO 'STRUCT=INFO 'STRUCT=INFO-CLASS
			     `(,STRUCT-CLASS))
	  (setplist 'CLASSP z))))

;; The following is an open-coding of part of the result of CONS-A-STRUCT=INFO.

(si:defvst-bare-init 'STRUCT=INFO 'STRUCT=INFO-CLASS 'CONS-A-STRUCT=INFO 6
		     '( ()				;&REST info
		       (VERS STRUCT=INFO-VERS STRUCT=INFO-VERSION )  ;1st key
		       (NAME STRUCT=INFO-NAME () )	;2st key
		       (CNSN STRUCT=INFO-CNSN () )	;3nd
		       (SIZE STRUCT=INFO-SIZE 0 )	;4rd
		       (INIS STRUCT=INFO-INIS () )	;5th
		       (CLSS STRUCT=INFO-CLSS STRUCT=INFO-CLASS))
		     1)

#.(if (filep infile)
      `(MAPC #'(LAMBDA (CLASS)
		       (SETF (GET (SI:CLASS-PLIST CLASS) ':SOURCE-FILE)
			     ',(namestring (truename infile))))
	     (LIST CLASS-CLASS OBJECT-CLASS VECTOR-CLASS STRUCT-CLASS
		   STRUCT=INFO-CLASS SEQUENCE-CLASS)))


(when (status feature complr)
      #%(subload EXTHUK))ββ